home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / OLDGC / gc_top.t next >
Encoding:
Text File  |  1990-06-13  |  9.5 KB  |  262 lines
  1. (herald gc_top
  2.   (env tsys (osys gc)
  3.             (osys gc_weak)       ;; for the GC-WEAK-???-LISTs
  4.             (osys frame)         ;; vframe stuff (temporary)
  5.             (osys table)))       ;; %TABLE-VECTOR must be integrated here
  6.  
  7. ;;; Copyright (c) 1985 Yale University
  8. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  9. ;;; This material was developed by the T Project at the Yale University Computer 
  10. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  11. ;;; and to use it for any purpose is granted, subject to the following restric-
  12. ;;; tions and understandings.
  13. ;;; 1. Any copy made of this software must include this copyright notice in full.
  14. ;;; 2. Users of this software agree to make their best efforts (a) to return
  15. ;;;    to the T Project at Yale any improvements or extensions that they make,
  16. ;;;    so that these may be included in future releases; and (b) to inform
  17. ;;;    the T Project of noteworthy uses of this software.
  18. ;;; 3. All materials developed as a consequence of the use of this software
  19. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  20. ;;;    of acknowledging credit in academic research.
  21. ;;; 4. Yale has made no warrantee or representation that the operation of
  22. ;;;    this software will be error-free, and Yale is under no obligation to
  23. ;;;    provide any services, by way of maintenance, update, or otherwise.
  24. ;;; 5. In conjunction with products arising from the use of this material,
  25. ;;;    there shall be no use of the name of the Yale University nor of any
  26. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  27. ;;;    without prior written consent from Yale in each case.
  28. ;;;
  29.  
  30. (lset *old-space* nil)
  31.  
  32. (lset *new-space* nil)
  33.  
  34. (define-simple-switch gc-noisily? boolean? '#f)
  35.  
  36. (lset *pre-gc-agenda*
  37.   (list pre-gc-fix-weak-sets
  38.         pre-gc-fix-weak-alists
  39.         pre-gc-fix-weak-tables
  40.         ))
  41.  
  42. (lset *post-gc-agenda*
  43.   (list post-gc-fix-weak-tables
  44.         post-gc-fix-weak-sets     ; fix any new ones
  45.         post-gc-fix-weak-alists
  46.         object-unhash-post-gc
  47.         ))
  48.  
  49. ;;;  GC sensitive things:
  50. ;;;                     PRE         POST
  51. ;;;    weaks             +           +
  52. ;;;    vcells            +           +
  53. ;;;    populations                   +      GC-UPDATE-THE-POPULATIONS
  54. ;;;    tables
  55. ;;;    pools             +                  POOL-PRE-GC-HOOK
  56. ;;;    streams                       +
  57. ;;;    free list         +                  PAIR-FREELIST-PRE-GC-HOOK
  58.  
  59. (lset *gc-problem?*         nil)
  60. (lset *gc-problem?-default* nil)
  61.  
  62. (define-operation (synch-area  area))
  63. (define-operation (reset-area  area))
  64. (define-operation (write-area  area))
  65.  
  66. (define-integrable (incr-area-frontier area length)
  67.   (set (area-frontier area) (fx+ (area-frontier area) length)))
  68.  
  69. (define-integrable (area-extent area)
  70.   (fx- (area-frontier area) (area-begin area)))
  71.  
  72. (define-structure-type area
  73.   id               
  74.   uid              ; for gc debugging (id,uid) must come first
  75.   size
  76.   base             ; base of area as an extend - see GC-FLIP
  77.   begin            ; base of area as a fixnum
  78.   frontier         ;++ changed from POINTER
  79.   limit            ; consing beyond this point causes a GC
  80.   (((reset-area self)
  81.     (if (eq? self (current-area))
  82.         (error "(reset-area ~s): area is current" self))
  83.     (set (area-base self) 0)
  84.     (zero-out-area self)
  85.     (set (area-frontier self) (area-begin self)))
  86.    ((synch-area self)
  87.     (if (neq? self (current-area))
  88.         (error "(synch-area ~s): area is not current" self))
  89.     (set (area-frontier self) (system-global slink/area-frontier)))
  90.    ((write-area self fd)
  91.     (vm-write-block fd (area-base self) (area-extent self)))
  92.    ((print-type-string self) "Area")
  93.    ((identification self) (area-id self))))
  94.  
  95. ;++flush uid ar 
  96.  
  97. (define (create-area id begin size uid)
  98.   (let ((area (make-area)))
  99.     (set (area-begin area) begin)
  100.     (set (area-frontier area) begin)
  101.     (set (area-limit area) (fx+ begin size))
  102.     (set (area-id area) id)
  103.     (set (area-uid area) uid)
  104.     (set (area-size area) size)
  105.     area))
  106.  
  107. (define-integrable (current-area)
  108.   (system-global slink/area))
  109.  
  110. (define (area-space-remaining)
  111.   (fx- (area-limit (current-area))
  112.        (system-global slink/area-frontier)))
  113.  
  114. (define (really-gc stack gc-frame)
  115.   (let ((z     *z?*))
  116.     (set *z?* t)
  117.     (set *gc-problem?* *gc-problem?-default*)
  118.     (gc-write-line ";Beginning GC")
  119.     (walk1 (lambda (item) (item)) *pre-gc-agenda*)
  120.     (gc-write-line ";*PRE-GC-AGENDA* done")
  121.     (gc-flip)
  122.     (gc-write-line ";GC-FLIP done")
  123.     (initialize-gc-stats)  ;;; Must come after flip
  124.     (object-unhash-pre-gc) ;;; Must come after flip
  125.     (set (system-global slink/pair-freelist) nil)
  126.     (set (system-global slink/snapper-freelist) nil)
  127.     (flush-code-vectors)
  128.     (gc-write-line ";Starting to root")
  129.     (gc-root stack gc-frame)
  130.     ;; The next line can't happen until after GC, when the area-object
  131.     ;; has been moved to new space.
  132.     (set (system-global slink/area) *new-space*)
  133.     (walk1 (lambda (item) (item)) *post-gc-agenda*)
  134.     (gc-write-line ";*POST-GC-AGENDA* done")
  135.     (set *z?* z)
  136.     (gc-done)
  137.     (gc-write-line ";GC done")
  138.     (if *gc-problem?* (breakpoint 'really-gc t-implementation-env))))
  139.  
  140. (define (gc-flip)
  141.   (exchange *old-space* *new-space*)
  142.   (synch-area *old-space*)
  143.   (set (system-global slink/old-space-begin) (area-begin *old-space*))
  144.   (set (system-global slink/old-space-frontier) (area-frontier *old-space*))
  145.   (set (system-global slink/area-frontier) (area-begin *new-space*))
  146.   (set (system-global slink/area-begin) (area-begin *new-space*))
  147.   (set (system-global slink/area-limit) (area-limit *new-space*))
  148.   (set (area-base *new-space*) (make-vector 0))
  149. ;  (advise-impure-area-access 'gc)
  150. ;  (advise-area-access *new-space* 'gc)
  151.   )
  152.  
  153. (define (gc-done)
  154. ;  (advise-impure-area-access 'random)
  155. ;  (advise-area-access *new-space* 'random)
  156.   (increment-gc-stamp)
  157.   (reset-area *old-space*)
  158. ;  (format t "; ~D objects copied~%" (fx+ *gc-click* *gc-object-count*))
  159.   (let ((free (fx- (system-global slink/area-limit)
  160.                    (system-global slink/area-frontier)))
  161.         (total (fx- (system-global slink/area-limit)
  162.                     (system-global slink/area-begin))))
  163.     (gc-write-line (format nil ";Space Remaining: ~D left out of ~D (~D% free)"
  164.               free total 
  165.           (->integer (+ .5 (* 1.0 (/ (* 100.0 free) total))))))))
  166.  
  167. (define (gc-root stack gc-frame)
  168.   (real-scan (system-global slink/initial-impure-base)
  169.              (system-global slink/initial-impure-memory-end)
  170.              impure-trace-proc)
  171.   (gc-write-line ";IIM traced")
  172.   (scan-stack stack (system-global slink/stack))
  173.   (scan-gc-frame gc-frame)
  174.   (gc-write-line ";Stack traced")
  175.   )
  176.  
  177. (define (impure-trace-proc ptr impure-offset ptrs scrs type)
  178.   (ignore impure-offset scrs)
  179.   (cond ((eq? type 'weak-cell)
  180.          (set (weak-cell-contents ptr) nil))
  181.         ((weak-semaphore-set? ptr)     ; Speed hack
  182.          (move-object (make-pointer ptr -1))
  183.          (trace-pointers ptr ptrs))
  184.         ((eq? type 'weak-set)
  185.          (set (extend-header ptr) (gc-weak-set-list))
  186.          (set (gc-weak-set-list) ptr))
  187.         ((eq? type 'weak-alist)
  188.          (set (extend-header ptr) (gc-weak-alist-list))
  189.          (set (gc-weak-alist-list) ptr))
  190.         ((eq? type 'weak-table)
  191.          (modify (%table-vector (weak-table-table ptr))
  192.                  (lambda (v) (set (weak-table-vector ptr) v) nil))
  193.          (set (extend-header ptr) (gc-weak-table-list))
  194.          (set (gc-weak-table-list) ptr)
  195.          (move-object (make-pointer ptr 0)))
  196.         (else
  197.          (move-object (make-pointer ptr -1))
  198.          (trace-pointers ptr ptrs))))
  199.  
  200. (define-constant template->frame-header!
  201.   (primop template->frame-header! ()
  202.     ((primop.side-effects? self) t)
  203.     ((primop.generate self node)                               
  204.      (let ((reg (->register node (leaf-value ((call-arg 2) node)))))
  205.        (emit risc/load 'l (reg-offset reg -2) scratch)
  206.        (emit risc/add (machine-num 2) scratch scratch)
  207.        (emit risc/store 'l scratch (reg-offset reg -2))))))
  208.  
  209. (define (scan-stack frame bottom)
  210.   (cond ((fx> frame bottom))
  211.     (else
  212.      (cond ((frame? frame)
  213.         (move-frame-header frame)
  214.         (if (not (fixnum? (extend-header frame))) ;forwarded
  215.             (template->frame-header! frame))
  216.         (let ((size (frame-size frame)))
  217.           (trace-pointers frame size)
  218.           (scan-stack (make-pointer frame size) bottom)))
  219.            (else
  220.         (gc-error-message "weird thing on stack" frame)
  221.         (scan-stack (make-pointer frame 0) bottom))))))
  222.  
  223.  
  224. (define (scan-gc-frame frame)
  225.   (trace-pointers frame (fx+ *argument-registers* 5)))
  226.  
  227. (define (scan-interrupt-frame frame)
  228.   (trace-pointers frame (fx+ *argument-registers* 6)))
  229.  
  230. (define (trace-pointers obj ptrs)
  231.   (do ((i 0 (fx+ i 1)))
  232.       ((fx>= i ptrs) t)
  233.     (move-object (make-pointer obj i))))
  234.  
  235. ;;; True if an object is in old space.
  236. (define (in-old-space? obj)
  237.   (let ((obj (descriptor->fixnum obj)))
  238.     (and (fx>= obj (system-global slink/old-space-begin))
  239.          (fx< obj (system-global slink/old-space-frontier)))))
  240.  
  241. ;;; True if an object is in new space.
  242. (define (in-new-space? obj)
  243.   (let ((obj (descriptor->fixnum obj)))
  244.     (and (fx>= obj (system-global slink/area-begin))
  245.          (fx< obj (system-global slink/area-frontier)))))
  246.  
  247. (define (flush-code-vectors)
  248.   (iterate loop ((l (weak-set-elements code-population)))
  249.     (cond ((null? l))
  250.       ((in-old-space? (car l))
  251.        (flush-code-from-icache (car l))
  252.        (loop (cdr l)))
  253.       (else (loop (cdr l))))))
  254.  
  255.  
  256. (define (gc-write-line string)
  257.   (fresh-line (error-output))
  258.   (write-string (error-output) string)
  259.   (newline (error-output)))
  260.  
  261. (set (gc-present?) '#t)
  262.